home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / sp_form.t < prev    next >
Text File  |  1988-02-05  |  5KB  |  158 lines
  1. (herald special_form
  2.   (env tsys))
  3.  
  4. ;;; Needs PATTERN
  5.  
  6. (define (make-syntax-descriptor id predicate)
  7.   (object nil
  8.     ((syntax-descriptor? self) t)
  9.     ((identification self) id)
  10.     ((print self stream)
  11.      (print-syntax-descriptor self stream))
  12.     ((syntax-check-predicate self) predicate)))
  13.  
  14. (define (print-syntax-descriptor self port)
  15.   (let ((id (identification self)))
  16.     (cond ((eq? self (syntax-table-entry standard-syntax-table id))
  17.            (format port "#[Syntax~_~S]" id))
  18.           ;; Temporary kludge - no JOIN.
  19.           ((or (eq? self 'quasiquote)
  20.                (eq? self 'unquote)
  21.                (eq? self 'unquote-splicing))
  22.            (format port "#[Internal-syntax~_~S]" id))
  23.           (else
  24. ;++ fix this
  25.            (format port "#{Syntax~_~S~_~S}"
  26.                    (object-hash self) id)))))
  27.  
  28. ;;; Used only by EVAL, this procedure in the process of being phased out.
  29.  
  30. (define (obtain-syntax-table-entry table symbol spect)
  31.   (ignore spect)
  32.   (cond ((syntax-table-entry table symbol)
  33.          => identity)
  34.         (else
  35.          (error "unknown special form ~S" symbol))))
  36.  
  37. ;;; All the special forms
  38.  
  39. ;;; OBJECT is still a macro for the interpreter and thus it is commented out
  40. ;;; below.
  41.  
  42. (define-local-syntax (define-special-form form)
  43.   (let ((pattern (if (null? (cdr form)) 'null? (cdr form))))
  44.     `(*define-syntax t-implementation-env
  45.                      ',(car form)
  46.                      (make-syntax-descriptor ',(car form)
  47.                                              (pattern-predicate ,pattern)))))
  48.  
  49. ;;; (QUOTE THING)
  50. ;;; (LAMBDA (VARS) . FORMS)
  51. ;;; (CALL PROC . ARGS)
  52. ;;; (BLOCK . FORMS)
  53. ;;; (SET-VARIABLE-VALUE ID VAL)
  54. ;;; (DEFINE-VARIABLE-VALUE ID VAL)
  55. ;;; (LSET-VARIABLE-VALUE ID VAL)
  56. ;;; (VAR-LOCATIVE ID)
  57. ;;; (DECLARE KEY . STUFF)
  58. ;;; (PRIMOP ID () . METHODS) or (PRIMOP ID (FORMALS) (METHODS) . METHODS) 
  59. ;;; (IF TEST CONSEQUENT . MAYBE-ALTERNATE)
  60. ;;; (LABELS (SPECS) . FORMS)
  61. ;;; (DEFINE-LOCAL-SYNTAX ID VALUE)
  62. ;;; (DEFINE-LOCAL-SYNTAX (ID . VARS) . FORMS)
  63. ;;; (LET-SYNTAX (SPECS) . FORMS)
  64. ;;; (OBJECT PROC . METHODS)
  65. ;;; (THE-ENVIRONMENT)
  66. ;;; (LOCALE ID . FORMS)
  67.  
  68. (define-special-form (quote #f))
  69. (define-special-form (lambda formals-list? . (+ #f)))
  70. (define-special-form (call . (+ #f)))
  71. (define-special-form (block . (+ #f)))
  72. (define-special-form (set-variable-value symbol? #f))
  73. (define-special-form (define-variable-value symbol? #f))
  74. (define-special-form (lset-variable-value symbol? #f))
  75. (define-special-form (var-locative symbol?))
  76. (define-special-form (declare symbol? . (* #f)))
  77. (define-special-form (primop symbol? . (| (null? . (* valid-method-form?))
  78.                                           ((+ symbol?)
  79.                                            (* valid-method-form?)
  80.                                            . (* valid-method-form?)))))
  81. (define-special-form (if #f #f . (| null? (#f))))
  82. (define-special-form (labels (* valid-binding-spec?) . (+ #f)))
  83. (define-special-form (define-local-syntax . valid-binding-spec?))
  84. (define-special-form (let-syntax (* valid-binding-spec?) . (+ #f)))
  85. (define-special-form (object #f . (* valid-method-form?)))
  86. (define-special-form (the-environment))
  87. (define-special-form (locale identifier? . (* #f)))
  88.  
  89. (define-special-form
  90.  (define-foreign symbol?
  91.    (symbol? . (* (foreign-parameter-spec?
  92.                   foreign-representation-spec?
  93.                   . (| null? symbol?))))
  94.    symbol?))
  95.  
  96. ;;; Obsolete or questionable
  97.  
  98. (define-special-form (bound? symbol?))
  99. (define-special-form (variable-value symbol?))
  100. (define-special-form (named-lambda symbol? formals-list? . (+ #f)))
  101.  
  102. ;;; Useful predicates - where to put them?
  103.  
  104. (define (identifier? x)
  105.   (or (not x)
  106.       (symbol? x)))
  107.  
  108. (define (formals-list? l)
  109.   (iterate loop ((l l))
  110.     (cond ((null? l) t)
  111.           ((atom? l)
  112.            (identifier? l))
  113.           ((identifier? (car l))
  114.            (loop (cdr l)))
  115.           (else nil))))
  116.  
  117. ;;; BINDING-SPEC == (ID VALUE) or ((ID . VARS) . FORMS)
  118.  
  119. (define valid-binding-spec?
  120.   (pattern-predicate (| (symbol? #f)
  121.                         ((symbol? . formals-list?)
  122.                          . (+ #f)))))
  123.  
  124. ;;; METHOD == ((OP SELF-ID . IDS) . FORMS)
  125. ;;; where SELF-ID == ID or (SELF OBJ)
  126.  
  127. (define valid-method-form?
  128.   (let ((self-var? (pattern-predicate
  129.                     (| identifier?
  130.                        (identifier? identifier?)))))
  131.     (pattern-predicate ((#f self-var? . formals-list?) . (+ #f)))))
  132.  
  133.  
  134. ;;; Predicates for DEFINE-FOREIGN
  135.  
  136. (define (foreign-parameter-spec? obj)
  137.   (memq? obj '(IN OUT IN/OUT VAR IGNORE)))
  138.  
  139. (define (foreign-representation-spec? obj)
  140.   (memq? obj '(rep/integer
  141.                rep/integer-8-s
  142.                rep/integer-8-u
  143.                rep/integer-16-s
  144.                rep/integer-16-u
  145.                rep/char
  146.                rep/value
  147.                rep/extend
  148.                rep/extend-pointer
  149.                rep/string
  150.                rep/string-pointer
  151.                rep/pointer
  152.                rep/double)))
  153.  
  154. (define (foreign-return-spec? obj)
  155.   (or (foreign-representation-spec? obj)
  156.       (eq? obj 'rep/address)
  157.       (eq? obj 'ignore)))
  158.